Night Owl 6/Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso/037a/wedits22.zip/WWIVOUTP.PAS

Pascal/Delphi Source File | 1991-08-15 | 6KB | 289 lines

UNIT WWIVOutp;
{$D-}
{{$DEFINE b1200}
INTERFACE

CONST
  Black        = 0;
  Blue         = 1;
  Green        = 2;
  Cyan         = 3;
  Red          = 4;
  Magenta      = 5;
  Brown        = 6;
  LightGray    = 7;
  DarkGray     = 8;
  LightBlue    = 9;
  LightGreen   = 10;
  LightCyan    = 11;
  LightRed     = 12;
  LightMagenta = 13;
  Yellow       = 14;
  White        = 15;
  Blink        = 128;
  C0 = ^C'0';
  C1 = ^C'1';
  C2 = ^C'2';
  C3 = ^C'3';
  C4 = ^C'4';
  C5 = ^C'5';
  C6 = ^C'6';
  C7 = ^C'7';

PROCEDURE GotoXY(x,y:integer);
PROCEDURE ClrScr;
PROCEDURE ClrEol;
PROCEDURE TextColor(n:integer);
PROCEDURE TextBackground(n:integer);
PROCEDURE Print(s:string);
PROCEDURE Prompt(s:string);
FUNCTION  WhereX : byte;
FUNCTION  WhereY : byte;

IMPLEMENTATION

USES CRT, DOS;

TYPE
  Translation = (None, Bios, DirectVideo, ANSI);

VAR
  OldOutput : text;
  Translate : Translation;
  CenterString : string;
  ESCString : string;


FUNCTION  WhereX : byte;
BEGIN
  WhereX:=Crt.WhereX;
END;


FUNCTION  WhereY : byte;
BEGIN
  WhereY:=Crt.WhereY;
END;

PROCEDURE Print(s:string);
BEGIN
  writeln(s);
END;

PROCEDURE Prompt(s:string);
BEGIN
  write(s);
END;

PROCEDURE TextColor;
BEGIN
  Crt.Textcolor(n);
END;

PROCEDURE TextBackground;
BEGIN
  Crt.textbackground(n);
END;

PROCEDURE GotoXY(x,y:integer);
BEGIN
  Crt.gotoxy(x,y);
{$IFDEF b1200}
  delay(8*12);
{$ENDIF}
{$IFDEF b2400}
  delay(8*6);
{$ENDIF}
END;

PROCEDURE ClrScr;
BEGIN
{$IFDEF b1200}
  delay(4*12);
{$ENDIF}
{$IFDEF b2400}
  delay(4*6);
{$ENDIF}
  Crt.ClrScr
END;

PROCEDURE ClrEol;
BEGIN
{$IFDEF b1200}
  delay(4*12);
{$ENDIF}
{$IFDEF b2400}
  delay(4*6);
{$ENDIF}

  Crt.ClrEol
END;


PROCEDURE Color(f,b:byte);
BEGIN
  TextColor(f);
  TextBackground(b);
END;


PROCEDURE DoColor(ch:char);
BEGIN
{$IFDEF b1200}
  delay(12);
{$ENDIF}
{$IFDEF b2400}
  delay(6);
{$ENDIF}
  CASE ch OF
    '0' : Color(LightGray,Black);
    '1' : Color(LightCyan,Black);
    '2' : Color(Yellow,Black);
    '3' : Color(Magenta,Black);
    '4' : Color(White,Blue);
    '5' : Color(Green,Black);
    '6' : Color(Red+Blink,Black);
    '7' : Color(LightBlue,Black);
    ELSE  Color(LightGray,Black);
  END;
END;

PROCEDURE Center(VAR s:string);
VAR
  i,l : integer;
BEGIN
  l:=0;
  FOR i:=1 TO length(s) DO
  BEGIN
    inc(l);
    IF s[i]=^C THEN dec(l,2);
  END;
  FOR i:=1 TO 40-(l div 2) DO
    write(OldOutput,' ');
  WHILE s<>'' DO
    IF s[1]<>^C THEN
    BEGIN
      write(OldOutput,s[1]);
      delete(s,1,1);
    END
    ELSE BEGIN
      DoColor(s[2]);
      delete(s,1,2);
    END;
END;

{$F+}
FUNCTION DoNothing(VAR f:TextRec):integer;
BEGIN
  DoNothing :=0;
END;

FUNCTION TranslateOutput(VAR f:TextRec):integer;
VAR
  i:integer;
  ch : char;
  p : integer;
  x, y, e : integer;
BEGIN
  WITH f DO
    FOR i:=0 TO BufPos-1 DO
    BEGIN
      ch :=BufPtr^[i];
      CASE UserData[1] OF
        0 : BEGIN
              IF Translate <> None THEN
              BEGIN
                IF ch=^C THEN
                  UserData[1]:=1
                ELSE
                IF ch=^L THEN
                  clrscr
                ELSE IF ch=^B THEN
                  UserData[1]:=2
                ELSE IF ch=^[ THEN
                  UserData[1]:=3
                ELSE
                  BEGIN
                    {$IFDEF b1200}
                      delay(12);
                    {$ENDIF}
                    {$IFDEF b2400}
                      delay(6);
                    {$ENDIF}
                    write(OldOutput,ch);
                  END
              END
              ELSE BEGIN
                write(OldOutput,ch);
                {$IFDEF b1200}
                  delay(12);
                {$ENDIF}
                {$IFDEF b2400}
                  delay(6);
                {$ENDIF}
              END;
        END;
        1 : BEGIN
              DoColor(ch);
              UserData[1]:=0;
            END;
        2 : IF ch<>^M THEN
              CenterString := CenterString + ch
            ELSE BEGIN
              Center(CenterString);
              UserData[1]:=0;
              write(OldOutput,^M);
              CenterString := '';
            END;
        3 : BEGIN
              ESCString:=EscString+ch;
              IF ch IN ['A'..'Z','a'..'z'] THEN
              BEGIN
                UserData[1]:=0;
                IF ESCString='[K' THEN ClrEol
                ELSE IF ESCString='[2J' THEN ClrScr
                ELSE IF ESCString='[7m' THEN Color(0,7)
                ELSE IF ESCString='[87m' THEN Color(7,0)
                ELSE IF ESCString='[47m' THEN TextBackground(7)
                ELSE IF ESCString='[0;30m' THEN TextColor(0)
                ELSE IF ch='D' THEN
                BEGIN
                  Delete(EscString,1,1);
                  Delete(EscString,length(escstring),1);
                  Val(escstring,x,y);
                  gotoxy(wherex-x,wherey);
                END
                ELSE IF ch='H' THEN
                BEGIN
                  p:=pos(';',EscString);
                  Val(copy(EscString,p+1,length(EscString)-p-1),x,e);
                  Val(copy(EscString,2,p-2),y,e);
                  gotoxy(x,y);
                END;
                EscString:='';
              END
            END;
      END;
    END;
    f.BufPos:=0;
    TranslateOutput:=0;
END;

{$F-}

BEGIN
  IF Copy(GetEnv('BBS'),1,4)='WWIV' THEN Translate:=NONE
  ELSE Translate:=DirectVideo;
  TextRec(OldOutput) := TextRec(OutPut);
  WITH TextRec(Output) DO
  BEGIN
    Mode:=fmOutput;
    InOutFunc := @TranslateOutput;
    FlushFunc := @TranslateOutput;
    GetMem(BufPtr,128);
    UserData[1]:=0;
  END;
  CenterString:='';
  ESCString:='';
  CheckSnow:=False;
END.